home *** CD-ROM | disk | FTP | other *** search
/ Gamers Delight 2 / Gamers Delight 2.iso / Aminet / game / gag / NetWork.lha / NetWork / NetWork.mod < prev    next >
Text File  |  1989-08-02  |  12KB  |  396 lines
  1. (*---------------------------------------------------------------------------
  2.     :Program.    NetWork.mod
  3.     :Author.     Fridtjof Siebert
  4.     :Address.    Nobileweg 67, D-7-Stgt-40
  5.     :Phone.      (0)711/822509
  6.     :Shortcut.   [fbs]
  7.     :Version.    1.0
  8.     :Date.       04-Jan-89 03:57:52
  9.     :Copyright.  PD
  10.     :Language.   Modula-II
  11.     :Translator. M2Amiga v3.1d
  12.     :Contents.   Program to create a NetWork on Workbench.
  13.     :Remark.     Idea by Achim Siebert
  14. ---------------------------------------------------------------------------*)
  15.  
  16. MODULE NetWork;
  17.  
  18. FROM SYSTEM      IMPORT ADR, ADDRESS, LONGSET, INLINE;
  19. FROM Arts        IMPORT Assert, TermProcedure, Terminate;
  20.  
  21. FROM Dos         IMPORT ctrlC, Delay;
  22. FROM Exec        IMPORT Forbid, Permit, FindPort, MsgPortPtr, NodeType,
  23.                         Message, MessagePtr, GetMsg, ReplyMsg, PutMsg, Wait,
  24.                         MemReqs, MemReqSet, WaitPort, FreeMem;
  25. FROM ExecSupport IMPORT CreatePort, DeletePort;
  26. FROM Graphics    IMPORT WaitBOVP, BitMap, SetDrMd, WaitTOF, RastPortPtr,
  27.                         BitMapPtr, BltBitMap, SetAPen, jam1, WritePixel,
  28.                         RastPort, InitBitMap, InitRastPort;
  29. FROM Intuition   IMPORT ScreenPtr, MakeScreen, RethinkDisplay, NewWindow,
  30.                         WindowFlags, WindowFlagSet, ScreenFlags, CloseWindow,
  31.                         ScreenFlagSet, IDCMPFlags, IDCMPFlagSet, OpenWindow,
  32.                         WindowPtr;
  33. FROM IFFSupport  IMPORT ReadILBM, ReadILBMFlags, ReadILBMFlagSet, NuScreen,
  34.                         IFFInfo;
  35. FROM Heap        IMPORT AllocMem;
  36.  
  37. (*------  CONSTS:  ------*)
  38.  
  39. CONST
  40.   WindowTitle = "NetWork © Fridtjof Siebert";
  41.   PortName    = "NewWBPlanes[fbs].Port";
  42.   ReplyName   = "NewWBPlanes[fbs].ReplyPort";
  43.   minx = 32;
  44.   miny = 16;
  45.  
  46. (*------  TYPES:  ------*)
  47.  
  48. TYPE
  49.   ColorMap =  ARRAY[0..31] OF INTEGER;
  50.  
  51. (*------  VARS:  ------*)
  52.  
  53. VAR
  54.   WBScreen,SDummy: ScreenPtr;
  55.   CMap: ColorMap;
  56.   OldColTable: POINTER TO ColorMap;
  57.   Window,WDummy: WindowPtr;
  58.   NuWindow: NewWindow;
  59.   MyMsg: Message;
  60.   QuitMessage: MessagePtr;
  61.   MyPort, OldPort: MsgPortPtr;
  62.   i: INTEGER;
  63.   rp: RastPort;
  64.   bm: BitMap;
  65.   SpiderBM: BitMapPtr;
  66.   SpiderSaveBM: BitMap;
  67.   SpiderX,SpiderY: INTEGER;
  68.   W,H,D,R,Hx,Hy,X6,Y6: INTEGER;
  69.   FirstDraw: BOOLEAN;
  70.   SpidOffSetX,SpidOffSetY: INTEGER;
  71.   Factor: LONGINT;
  72.   LinNum: CARDINAL;
  73.   x,y: INTEGER;
  74.   Line: ARRAY[0..23] OF RECORD
  75.                          x,y: INTEGER;
  76.                          dx,dy: LONGINT;
  77.                        END;
  78.  
  79. (*------  CleanUp:  ------*)
  80.  
  81. PROCEDURE CleanUp();
  82.  
  83. BEGIN
  84.  
  85. (*------  Remove IFF:  ------*)
  86.  
  87.   IF SpiderBM#NIL THEN
  88.     WITH SpiderBM^ DO
  89.       i:=0;
  90.       WHILE i#ORD(depth) DO
  91.         FreeMem(planes[i],rows*bytesPerRow);
  92.         INC(i);
  93.       END;
  94.     END;
  95.     FreeMem(SpiderBM,SIZE(BitMap));
  96.   END;
  97.  
  98.  
  99. (*------  Remove Picture from WB:  ------*)
  100.  
  101.   IF WBScreen#NIL THEN
  102.     Forbid();
  103.       IF OldColTable#NIL THEN
  104.         WBScreen^.viewPort.colorMap^.colorTable := OldColTable;
  105.       END;
  106.       WITH WBScreen^.bitMap DO
  107.         depth := 2;
  108.         planes[2] := NIL;
  109.       END;
  110.       MakeScreen(WBScreen);
  111.     Permit();
  112.     RethinkDisplay();
  113.   END;
  114.  
  115. (*------  Close everything:  ------*)
  116.  
  117.   IF Window#NIL THEN CloseWindow(Window); END;
  118.  
  119. (*------  Remove Port:  ------*)
  120.  
  121.   IF MyPort#NIL THEN
  122.     Forbid();
  123.       IF QuitMessage=NIL THEN QuitMessage := GetMsg(MyPort) END;
  124.       WHILE QuitMessage#NIL DO
  125.         ReplyMsg(QuitMessage);
  126.         QuitMessage := GetMsg(MyPort);
  127.       END;
  128.       DeletePort(MyPort);
  129.     Permit();
  130.   END;
  131.  
  132. END CleanUp;
  133.  
  134. (*------  Put Spiderplanes on WBScreen:  ------*)
  135.  
  136. PROCEDURE Rethink();
  137.  
  138. BEGIN
  139.   WITH WBScreen^.bitMap DO
  140.     WaitTOF();
  141.     Forbid();
  142.       depth := 4;
  143.       MakeScreen(WBScreen);
  144.       depth := 2;
  145.     Permit();
  146.     RethinkDisplay();
  147.   END;
  148. END Rethink;
  149.  
  150. (*------  Let Spider draw a line:  ------*)
  151.  
  152. PROCEDURE SpiderLine(ex,ey: INTEGER; draw: BOOLEAN);
  153.  
  154. VAR
  155.   sdDir: CARDINAL;
  156.   dx,dy,xinc,yinc: INTEGER;
  157.   dirx,diry: BOOLEAN;
  158.   count: INTEGER;
  159.   sdpos: INTEGER;
  160.   sdposdir,p,sy: INTEGER;
  161.   Duese: POINTER TO ARRAY [0..7] OF RECORD x,y: INTEGER END;
  162.  
  163.   PROCEDURE DueseTable(); (* $E- *)
  164.   BEGIN
  165.     INLINE(17,11,20, 9,26, 8,27, 9,32,12,27,15,22,15,16,14);
  166.   END DueseTable;
  167.  
  168. BEGIN
  169.   Duese := ADR(DueseTable);
  170.   dx:= ex-SpiderX;
  171.   dy:= ey-SpiderY;
  172.   IF (dx=0) AND (dy=0) THEN RETURN END;
  173.   IF    (dx>0) AND (ABS(dx)>ABS(dy)*4) THEN sdDir := 0;
  174.   ELSIF (dy>0) AND (ABS(dy)>ABS(dx))   THEN sdDir := 2;
  175.   ELSIF (dx<0) AND (ABS(dx)>ABS(dy)*4) THEN sdDir := 4;
  176.   ELSIF (dy<0) AND (ABS(dy)>ABS(dx))   THEN sdDir := 6;
  177.   ELSIF (dx>0) AND (dy>0)              THEN sdDir := 1;
  178.   ELSIF (dx>0) AND (dy<0)              THEN sdDir := 7;
  179.   ELSIF (dx<0) AND (dy>0)              THEN sdDir := 3;
  180.   ELSIF (dx<0) AND (dy<0)              THEN sdDir := 5;
  181.   END;
  182.   IF dx>0 THEN xinc:=1 ELSE xinc := -1 END;
  183.   IF dy>0 THEN yinc:=1 ELSE yinc := -1 END;
  184.   dx := ABS(dx); dy := ABS(dy);
  185.   dirx := dx>dy;
  186.   IF dirx THEN count := dx/2 ELSE count := dy/2 END;
  187.   sdpos := 0; sdposdir := 1;
  188.   SetAPen(ADR(rp),2); SetDrMd(ADR(rp),jam1);
  189.   REPEAT
  190.     IF FirstDraw THEN FirstDraw:= FALSE ELSE
  191.       p := BltBitMap(ADR(SpiderSaveBM),0,0,ADR(bm),SpiderX-SpidOffSetX,
  192.              SpiderY-SpidOffSetY,49,25,192,255,NIL);
  193.     END;
  194.     SpidOffSetX := Duese^[sdDir].x;
  195.     SpidOffSetY := Duese^[sdDir].y;
  196.     IF dirx THEN
  197.       INC(SpiderX,xinc);
  198.       INC(count,dy);
  199.       IF count>=dx THEN
  200.         DEC(count,dx);
  201.         INC(SpiderY,yinc)
  202.       ELSIF SpiderX#ex THEN
  203.         IF draw THEN p:= WritePixel(ADR(rp),SpiderX,SpiderY) END;
  204.         INC(SpiderX,xinc);
  205.         INC(count,dy);
  206.         IF count>=dx THEN DEC(count,dx); INC(SpiderY,yinc) END;
  207.       END;
  208.     ELSE
  209.       INC(SpiderY,yinc);
  210.       INC(count,dx);
  211.       IF count>=dy THEN DEC(count,dy); INC(SpiderX,xinc) END;
  212.     END;
  213.     IF draw THEN p:= WritePixel(ADR(rp),SpiderX,SpiderY) END;
  214.     p := BltBitMap(ADR(bm),SpiderX-SpidOffSetX,SpiderY-SpidOffSetY,
  215.            ADR(SpiderSaveBM),0,0,49,25,192,255,NIL);
  216.     CASE sdpos DIV 3 OF 0: sy := 24| 1: sy := 0| 2: sy := 48 END;
  217.     p := BltBitMap(SpiderBM,48*sdDir,sy,ADR(bm),
  218.        SpiderX-SpidOffSetX,SpiderY-SpidOffSetY,49,25,224,255,NIL);
  219.     INC(sdpos,sdposdir);
  220.     IF (sdpos=0) OR (sdpos=8) THEN sdposdir := -sdposdir END;
  221.     IF draw THEN WaitTOF(); WaitBOVP(ADR(WBScreen^.viewPort)) END;
  222.   UNTIL ((SpiderX=ex) AND dirx) OR ((SpiderY=ey) AND NOT(dirx));
  223.   SpiderX := ex; SpiderY := ey;
  224.   QuitMessage := GetMsg(MyPort);
  225.   IF QuitMessage#NIL THEN Terminate(0) END;
  226.   Rethink();
  227. END SpiderLine;
  228.  
  229. (*------  MAIN:  ------*)
  230.  
  231. BEGIN
  232.  
  233. (*------  Initialization:  ------*)
  234.  
  235.   WBScreen := NIL; OldColTable := NIL; Window := NIL; MyPort := NIL;
  236.   SpiderBM := NIL;
  237.   TermProcedure(CleanUp);
  238.  
  239. (*------  Have we already been started?  ------*)
  240.  
  241.   OldPort := FindPort(ADR(PortName));
  242.   IF OldPort#NIL THEN
  243.     MyPort := CreatePort(ADR(ReplyName),0);
  244.     Assert(MyPort#NIL,ADR("CreatePort failed"));
  245.     MyMsg.node.type := message;
  246.     MyMsg.replyPort := MyPort;
  247.     PutMsg(OldPort,ADR(MyMsg)); (* Signal task to quit *)
  248.     WaitPort(MyPort);
  249.     DeletePort(MyPort);
  250.     MyPort := NIL;
  251.     Terminate(0);
  252.   END;
  253.   MyPort := CreatePort(ADR(PortName),0);
  254.   Assert(MyPort#NIL,ADR("CreatePort failed"));
  255.  
  256. (*------  Open Window:  ------*)
  257.  
  258.   WITH NuWindow DO
  259.     leftEdge   := 0; topEdge     := 0;
  260.     width      := 1; height      := 1;
  261.     detailPen  := 0; blockPen    := 1;
  262.     idcmpFlags := IDCMPFlagSet{};
  263.     flags      := WindowFlagSet{backDrop};
  264.     firstGadget:= NIL; checkMark := NIL;
  265.     title      := ADR(WindowTitle);
  266.     screen     := NIL; bitMap    := NIL;
  267.     type       := ScreenFlagSet{wbenchScreen};
  268.   END;
  269.   Window := OpenWindow(NuWindow);
  270.   Assert(Window#NIL,ADR("Can't open Window!!!"));
  271.   WBScreen := Window^.wScreen;
  272.   IF WBScreen^.bitMap.depth>2 THEN Terminate(0) END;
  273.  
  274. (*------  Load Spiders:  ------*)
  275.  
  276.   Assert(ReadILBM("NetWork.Handler",ReadILBMFlagSet{visible,dontopen},SDummy,
  277.          WDummy),ADR("Can't load SpinnenSort.iff"));
  278.   SpiderBM := NuScreen.customBitMap;
  279.  
  280. (*------  Set Colors:  ------*)
  281.  
  282.   OldColTable := WBScreen^.viewPort.colorMap^.colorTable;
  283.   CMap := OldColTable^;
  284.   FOR i:=0 TO 3 DO
  285.     CMap[ 4+i] := 0000H;
  286.     CMap[ 8+i] := 0DDDH;
  287.     CMap[12+i] := 0000H;
  288.   END;
  289.   WBScreen^.viewPort.colorMap^.colorTable := ADR(CMap);
  290.  
  291. (*------  Add Planes to WBScreen:  ------*)
  292.  
  293.   bm := WBScreen^.bitMap;
  294.   WITH bm DO
  295.     AllocMem(planes[0],rows*bytesPerRow,TRUE);
  296.     Assert(planes[0]#NIL,ADR("Out of memory"));
  297.     AllocMem(planes[1],rows*bytesPerRow,TRUE);
  298.     Assert(planes[1]#NIL,ADR("Out of memory"));
  299.     WBScreen^.bitMap.planes[2] := planes[0];
  300.     WBScreen^.bitMap.planes[3] := planes[1];
  301.   END;
  302.  
  303. (*------  Init SpiderSaveBM:  ------*)
  304.  
  305.   InitBitMap(SpiderSaveBM,2,64,32);
  306.   WITH SpiderSaveBM DO
  307.     AllocMem(planes[0],rows*bytesPerRow,TRUE);
  308.     AllocMem(planes[1],rows*bytesPerRow,TRUE);
  309.     Assert((planes[0]#NIL) AND (planes[1]#NIL),ADR("Out of memory!"));
  310.   END;
  311.  
  312. (*------  Init RastPort:  ------*)
  313.  
  314.   bm.depth := 2;
  315.   InitRastPort(rp);
  316.   rp.bitMap := ADR(bm);
  317.  
  318. (*------  Create NetWork:  ------*)
  319.  
  320.   WITH WBScreen^ DO
  321.     W := width-2*minx;  R := width-minx;  Hx := minx + W DIV 2;
  322.     H := height-2*miny; D := height-miny; Hy := miny + H DIV 2;
  323.   END;
  324.   Rethink();
  325.  
  326. (*------  Gerüst:  ------*)
  327.  
  328.   SpiderX := minx; SpiderY := miny; FirstDraw := TRUE;
  329.   SpiderLine(minx,D   ,TRUE);
  330.   SpiderLine(R   ,miny,TRUE);
  331.   SpiderLine(minx,miny,TRUE);
  332.   SpiderLine(R   ,D   ,TRUE);
  333.   SpiderLine(R   ,Hy  ,TRUE);
  334.   SpiderLine(minx,Hy  ,TRUE);
  335.   SpiderLine(minx,D   ,TRUE);
  336.   SpiderLine(Hx  ,D   ,TRUE);
  337.   SpiderLine(Hx  ,miny,TRUE);
  338.   SpiderLine(R   ,miny,TRUE);
  339.   SpiderLine(R   ,D   ,TRUE);
  340.   SpiderLine(Hx  ,D   ,TRUE);
  341.   SpiderLine(Hx  ,Hy  ,TRUE);
  342.  
  343.   X6 := W DIV 6; Y6 := H DIV 6;
  344.   W  := W DIV 2; H  := H DIV 2;
  345.   WITH Line[ 0] DO x := Hx;        y := D;         dx :=  0;    dy := -H    END;
  346.   WITH Line[ 1] DO x := Hx + X6;   y := D;         dx := -X6;   dy := -H    END;
  347.   WITH Line[ 2] DO x := Hx + 2*X6; y := D;         dx := -2*X6; dy := -H    END;
  348.   WITH Line[ 3] DO x := R;         y := D;         dx := -W;    dy := -H    END;
  349.   WITH Line[ 4] DO x := R;         y := D - Y6;    dx := -W;    dy := -2*Y6 END;
  350.   WITH Line[ 5] DO x := R;         y := D - 2*Y6;  dx := -W;    dy := -Y6   END;
  351.   WITH Line[ 6] DO x := R;         y := Hy;        dx := -W;    dy :=  0    END;
  352.   WITH Line[ 7] DO x := R;         y := Hy - Y6;   dx := -W;    dy :=  Y6   END;
  353.   WITH Line[ 8] DO x := R;         y := Hy - 2*Y6; dx := -W;    dy :=  2*Y6 END;
  354.   WITH Line[ 9] DO x := R;         y := miny;      dx := -W;    dy :=  H    END;
  355.   WITH Line[10] DO x := R - X6;    y := miny;      dx := -2*X6; dy :=  H    END;
  356.   WITH Line[11] DO x := R - 2*X6;  y := miny;      dx := -X6;   dy :=  H    END;
  357.   WITH Line[12] DO x := Hx;        y := miny;      dx :=  0;    dy :=  H    END;
  358.   WITH Line[13] DO x := Hx - X6;   y := miny;      dx :=  X6;   dy :=  H    END;
  359.   WITH Line[14] DO x := Hx - 2*X6; y := miny;      dx :=  2*X6; dy :=  H    END;
  360.   WITH Line[15] DO x := minx;      y := miny;      dx :=  W;    dy :=  H    END;
  361.   WITH Line[16] DO x := minx;      y := Hy - 2*Y6; dx :=  W;    dy :=  2*Y6 END;
  362.   WITH Line[17] DO x := minx;      y := Hy - Y6;   dx :=  W;    dy :=  Y6   END;
  363.   WITH Line[18] DO x := minx;      y := Hy;        dx :=  W;    dy :=  0    END;
  364.   WITH Line[19] DO x := minx;      y := Hy + Y6;   dx :=  W;    dy := -Y6   END;
  365.   WITH Line[20] DO x := minx;      y := Hy + 2*Y6; dx :=  W;    dy := -2*Y6 END;
  366.   WITH Line[21] DO x := minx;      y := D;         dx :=  W;    dy := -H    END;
  367.   WITH Line[22] DO x := Hx - 2*X6; y := D;         dx :=  2*X6; dy := -H    END;
  368.   WITH Line[23] DO x := Hx - X6;   y := D;         dx :=  X6;   dy := -H    END;
  369.  
  370.   LinNum := 0; Factor := 0F800H;
  371.  
  372.   REPEAT
  373.     DEC(Factor,256);
  374.     IF LinNum=23 THEN LinNum := 0 ELSE INC(LinNum) END;
  375.     WITH Line[LinNum] DO
  376.       IF (LinNum DIV 3) * 3 = LinNum THEN
  377.         SpiderLine(x + (dx*Factor) DIV 10000H,y + (dy*Factor) DIV 10000H,TRUE);
  378.       ELSE
  379.         SpiderLine(x + (dx*(Factor + 400H)) DIV (0E000H + Factor DIV 8),
  380.                    y + (dy*(Factor + 400H)) DIV (0E000H + Factor DIV 8),TRUE);
  381.       END;
  382.     END;
  383.   UNTIL Factor=0200H;
  384.  
  385.   LOOP
  386.     Delay(50);
  387.     WITH WBScreen^ DO x := mouseX; y := mouseY END;
  388.     IF (x>minx) AND (y>miny) AND (x<R) AND (y<D) THEN
  389.       SpiderLine(x,y,FALSE);
  390.     ELSE
  391.       SpiderLine(Hx,Hy,FALSE);
  392.     END;
  393.   END;
  394.  
  395. END NetWork.
  396.